perm filename QSPEXP.F4[MUS,LCS] blob sn#107317 filedate 1974-06-16 generic text, type T, neo UTF8
00100		SUBROUTINE SPEED(Q)
00200		COMMON/RD/TM(50),SP1(50),SP2(50),SFAC(512)/XX/F(5,512)
00300		COMMON XS(100),YS(100),N,X1(512),Y1(512),S(100),K
00400		DIMENSION X2(512),Y2(512)
00500		EQUIVALENCE (X2,F(1,1)),(Y2,F(1,256))
13200	24	FORMAT(' SET TOTAL TIME='$)
13300		TYPE 24
13400		ACCEPT 30,TIME
13500		IF(TIME)GO TO 12
13550		TX=0
13600		AB=.3
13700		NSP=1
13800	CC	GO TO 254
13900	250	TYPE 25
13910	30	FORMAT(3F)
14000	25	FORMAT(' TIME, SPD1, SPD2 -- '$)
14100		ACCEPT 30,AB,SP1(NSP),SP2(NSP)
14200		IF(AB.EQ.-99)GO TO 12
14300		IF(AB)GO TO 251
14305		TX=TX+AB
14315	254	J=TX/TIME*512.
14320		IF(J.EQ.0)J=1
14500	CC	NX=X1(J)*10.
14600	CC	NY=Y1(J)*10.
14700	CC	CALL SETCUR(NX,NY,0)
14800		TM(NSP)=AB
14900		IF(TX.GE.TIME)GO TO 253
15000		NSP=NSP+1
15100		GO TO 250
15200	251	NSP=NSP-1
15300		IF(NSP.LE.0)NSP=1
15400		AB=TM(NSP)
15500		TYPE 30,AB,SP1(NSP)
15600		GO TO 254
15700	253	TM(NSP+1)=0
15850	
16100		SP=0
16200		DO 1 K=1,50
16300		IF(TM(K).EQ.0)GO TO 10
16400		SP=SP+TM(K)*(SP1(K)+SP2(K))/2.
16500	1	TM(K)=512.*TM(K)/TIME
16600	C  SETS SPEED FACTORS - AND TIME IN TERMS OF 512 UNITS.
16700	10	SP=TIME/SP
16710		K=0
16720		N=0
16740		H=1-SP
16800	2	G=0
17000		N=N+1
17005	C  RESETS FOR NEXT TIME UNIT
17100		DIF=SP2(N)-SP1(N)
17200	C  TOTAL SPEED CHANGE
17300	11	K=K+1
17400		G=G+1
17500		H=H+SP*(G/TM(N)*DIF+SP1(N))
17600		SFAC(K)=H+.00001
17605	C  WILL IT END UP ON 512??????
17610		IF(K.EQ.512)GO TO 12
17700		IF(G.GE.TM(N))GO TO 2
17800		GO TO 11
17900		C  TD=TOTAL DISTANCE OF PATH
18000	12	DO 3 K=1,511
18100		J=K+1
18200		Q=SFAC(K)
18300		L=Q
18400	CC	R=SFAC(J)
18500	CC	M=R
18600		A=X1(L)
18700		B=X1(L+1)
18800	CC	C=R-L
18900		D=B-A
19000	C  DIF IN DISTS.
19010		E=Q-L
19100		X2(K)=A+D*E
19300		A=Y1(L)
19310		B=Y1(L+1)
19320		D=B-A
19400	3	Y2(K)=A+D*E
19410		DO 4 K=1,511
19420		X1(K)=X2(K)
19430	4	Y1(K)=Y2(K)
40000		END